home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / forth / pfe-0.000 / pfe-0 / pfe-0.9.13 / src / toolkit.c < prev    next >
Encoding:
C/C++ Source or Header  |  1995-07-17  |  4.8 KB  |  247 lines
  1. /*
  2.  * This file is part of the portable Forth environment written in ANSI C.
  3.  * Copyright (C) 1995  Dirk Uwe Zoller
  4.  *
  5.  * This library is free software; you can redistribute it and/or
  6.  * modify it under the terms of the GNU Library General Public
  7.  * License as published by the Free Software Foundation; either
  8.  * version 2 of the License, or (at your option) any later version.
  9.  *
  10.  * This library is distributed in the hope that it will be useful,
  11.  * but WITHOUT ANY WARRANTY; without even the implied warranty of
  12.  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
  13.  * See the GNU Library General Public License for more details.
  14.  *
  15.  * You should have received a copy of the GNU Library General Public
  16.  * License along with this library; if not, write to the Free
  17.  * Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  18.  *
  19.  * This file is version 0.9.13 of 17-July-95
  20.  * Check for the latest version of this package via anonymous ftp at
  21.  *    roxi.rz.fht-mannheim.de:/pub/languages/forth/pfe-VERSION.tar.gz
  22.  * or    sunsite.unc.edu:/pub/languages/forth/pfe-VERSION.tar.gz
  23.  * or    ftp.cygnus.com:/pub/forth/pfe-VERSION.tar.gz
  24.  *
  25.  * Please direct any comments via internet to
  26.  *    duz@roxi.rz.fht-mannheim.de.
  27.  * Thank You.
  28.  */
  29. /*
  30.  * toolkit.c ---    The Optional Programming-Tools Word Set
  31.  * (duz 09Jul93)
  32.  */
  33.  
  34. #include "forth.h"
  35. #include "support.h"
  36. #include "compiler.h"
  37. #include "term.h"
  38.  
  39. #include <stdlib.h>
  40. #include <string.h>
  41. #include <ctype.h>
  42.  
  43. #include "missing.h"
  44.  
  45.  
  46. #define DECWIDTH (sizeof (Cell) * 5 / 2 + 1)
  47. #define HEXWIDTH (sizeof (Cell) * 2)
  48.  
  49.  
  50. static void
  51. printCell (Cell n)
  52. {
  53.   outf ("%*ld [%0*lX] ",
  54.     DECWIDTH, (long)n,
  55.     HEXWIDTH, (unsigned long)n);
  56. }
  57.  
  58. Code (dot_s)
  59. {
  60.   int i, dd, fd;
  61.  
  62.   dd = memtop.stack - sp;
  63.   fd = memtop.fstack - fp;
  64.   if (dd == 0)
  65.     if (fd == 0)
  66.       {
  67.     /* both stacks empty */
  68.     outf ("<stacks empty> ");
  69.       }
  70.     else
  71.       {
  72.     /* only floating point stack not empty */
  73.     outf ("\n<stack empty>%*.7G ",
  74.           (DECWIDTH + HEXWIDTH + 4 - 13) + 15, fp [0]);
  75.     for (i = 1; i < fd; i++)
  76.       outf ("\n%*.7G ",
  77.         (DECWIDTH + HEXWIDTH + 4) + 15, fp [i]);
  78.       }
  79.   else
  80.     if (fd == 0)
  81.       {
  82.     /* only data stack not empty */
  83.     for (i = 0; i < dd; i++)
  84.       {
  85.         cr_();
  86.         printCell (sp [i]);
  87.       }
  88.       }
  89.     else
  90.       {
  91.     int bd = dd < fd ? dd : fd;
  92.     for (i = 0; i < bd; i++)
  93.       {
  94.         cr_();
  95.         printCell (sp [i]);
  96.         outf ("%15.7G ", fp [i]);
  97.       }
  98.     for (; i < dd; i++)
  99.       {
  100.         cr_();
  101.         printCell (sp [i]);
  102.       }
  103.     for (; i < fd; i++)
  104.       outf ("\n%*.7G ",
  105.         (DECWIDTH + HEXWIDTH + 4) + 15, fp [i]);
  106.       }
  107. }
  108.  
  109. Code (question)
  110. {
  111.   fetch_();
  112.   dot_();
  113. }
  114.  
  115. Code (dump)
  116. {
  117.   uCell i, j, n = (uCell)*sp++;
  118.   Byte *p;
  119.  
  120.   POP (Byte *, sp, p);
  121.   cr_();
  122.   start_question_cr_();
  123.   outf ("%*s ", HEXWIDTH, "");
  124.   for (j = 0; j < 16; j++)
  125.     outf ("%02X ", (unsigned)((uCell)(p + j) & 0x0F));
  126.   for (j = 0; j < 16; j++)
  127.     outf ("%X", (unsigned)((uCell)(p + j) & 0x0F));
  128.   for (i = 0; i < n; i += 16, p += 16)
  129.     {
  130.       if (question_cr ())
  131.     break;
  132.       outf ("%0*lX ", HEXWIDTH, (unsigned long)(uCell)p);
  133.       for (j = 0; j < 16; j++)
  134.     outf ("%02X ", p [j]);
  135.       for (j = 0; j < 16; j++)
  136.     outf ("%c", printable (p [j]) ? p [j] : '.');
  137.     }
  138.   space_();
  139. }
  140.  
  141. Code (see)
  142. {
  143.   char *nfa;
  144.   Xt xt;
  145.  
  146.   nfa = tick (&xt);
  147.   decompile (nfa, xt);
  148. }
  149.  
  150. Code (words)
  151. {
  152.   Wordl *wl = CONTEXT [0] ? CONTEXT [0] : ONLY;
  153.   wild_words (wl, "*", NULL);
  154. }
  155.  
  156. /* Programming-Tools Extension words */
  157.  
  158. code (ahead)
  159. {
  160.   forward_mark_();
  161.   *--sp = ORIG_MAGIC;
  162. }
  163.  
  164. code (bye)
  165. {
  166.   save_buffers_();
  167.   close_all_files_();
  168.   if (option.quiet)
  169.     outc ('\n');
  170.   else
  171.     outs ("\nGoodbye!\n");
  172.   eXit (exitcode);
  173. }
  174.  
  175. Code (cs_pick)
  176. {
  177.   Cell n = (*sp-- + 1) << 1;
  178.   sp [0] = sp [n];
  179.   sp [1] = sp [n + 1];
  180. }
  181.  
  182. Code (cs_roll)
  183. {
  184.   Cell n = *sp++;
  185.   dCell h = ((dCell *)sp) [n];
  186.   for (; n > 0; n--)
  187.     ((dCell *)sp) [n] = ((dCell *)sp) [n - 1];
  188.   ((dCell *)sp) [0] = h;
  189. }
  190.  
  191. Code (forget)
  192. {
  193.   Xt xt;
  194.   unsmudge_();
  195.   forget (tick (&xt));
  196. }
  197.  
  198. Code (bracket_else)
  199. {
  200.   char *p;
  201.   int len, level = 1;
  202.  
  203.   do
  204.     {
  205.       for (;;)
  206.     {
  207.       p = word (' ');
  208.       if ((len = *(Byte *)p++) == 0)
  209.         break;
  210.       if (LOWER_CASE)
  211.         upper (p, len);
  212.       if (len == 4 && strncmp (p, "[IF]", 4) == 0)
  213.         ++level;
  214.       else    if (len == 6 && strncmp (p, "[ELSE]", 6) == 0)
  215.         if (--level == 0) return; else ++level;
  216.       else    if (len == 6 && strncmp (p, "[THEN]", 6) == 0)
  217.         if (--level == 0) return;
  218.     }
  219.     }
  220.   while (refill ());
  221.   tHrow (THROW_UNEXPECTED_EOF);
  222. }
  223.  
  224. Code (bracket_if)
  225. {
  226.   if (*sp++ == 0)
  227.     bracket_else_();
  228. }
  229.  
  230. LISTWORDS (toolkit) =
  231. {
  232.   CO (".S",        dot_s),
  233.   CO ("?",        question),
  234.   CO ("DUMP",        dump),
  235.   CO ("SEE",        see),
  236.   CO ("WORDS",        words),
  237.   CI ("AHEAD",        ahead),
  238.   CO ("BYE",        bye),
  239.   CO ("CS-PICK",    cs_pick),
  240.   CO ("CS-ROLL",    cs_roll),
  241.   CO ("FORGET",        forget),
  242.   CI ("[ELSE]",        bracket_else),
  243.   CI ("[IF]",        bracket_if),
  244.   CI ("[THEN]",        noop),
  245. };
  246. COUNTWORDS (toolkit, "Programming-Tools + parts of extensions");
  247.